perm filename MATCH[C,JRA] blob
sn#019581 filedate 1973-01-10 generic text, type T, neo UTF8
00100
00200 (GLOBAL (FUNCTIONS MATCH ASSIGNED?) (RESERVED !> !< !' !? !; !/,))
00300
00400 (DECLARE (SYMBOLS T)
00500 (GENPREFIX (QUOTE \M))
00600 (GENSYM (QUOTE M))
00700 (SPECIAL MALIST
00800 MALIST1
00900 MALIST2
01000 MALISTV1
01100 MALISTV2
01200 NOBIND
01300 VALV)
01400 (*LEXPR MATCH TRYASSIGN RVALUE VLOC)
01500 (*FEXPR CERR))
01600
01700 (DEFPROP MATCH
01800 (LAMBDA N
01900 ((LAMBDA(VARPAT DATAPAT)
02000 (PROG (MALIST1 MALIST2 MALISTV1 MALISTV2 NOBIND)
02100 (COND
02200 ((> N 2) (SETQ MALIST1 (ARG 3))
02300 (SETQ MALIST2 (ARG 4))
02400 (SETQ NOBIND T)))
02500 (SETQ MALISTV1 (GET (QUOTE MALIST1) (QUOTE VALUE)))
02600 (SETQ MALISTV2 (GET (QUOTE MALIST2) (QUOTE VALUE)))
02700 (RETURN
02800 (COND
02900 ((MATCH1 VARPAT DATAPAT)
03000 (LIST MALIST1 MALIST2))))))
03100 (ARG 1)
03200 (ARG 2)))
03300 EXPR)
03400
03500 (DECLARE (UNSPECIAL MALIST1 MALIST2))
03600
03700 (DEFPROP MATCH1
03800 (LAMBDA(VARPAT DATAPAT)
03900 (PROG (ACTOR1 ACTOR2)
04000 (RETURN
04100 (COND ((ATOM VARPAT)
04200 (MATCH2 DATAPAT VARPAT MALISTV2))
04300 ((ATOM DATAPAT)
04400 (MATCH2 VARPAT DATAPAT MALISTV1))
04500 ((EQ (SETQ ACTOR2 (CAR DATAPAT)) (QUOTE !')))
04600 ((MEMQ ACTOR2 (QUOTE (!< !?)))
04700 (MATCH2 VARPAT
04800 (ACTORSUBST DATAPAT (CDR MALISTV2))
04900 MALISTV1))
05000 ((EQ (SETQ ACTOR1 (CAR VARPAT)) (QUOTE !>))
05100 (!> (CDR VARPAT) DATAPAT MALISTV1 MALISTV2))
05200 ((EQ ACTOR1 (QUOTE !?))
05300 (!? (CDR VARPAT)
05400 DATAPAT
05500 MALISTV1
05600 MALISTV2
05700 T))
05800 ((EQ ACTOR1 (QUOTE !'))
05900 (MBINDR (CADR VARPAT)
06000 (CDDR VARPAT)
06100 DATAPAT
06200 MALISTV1))
06300 ((EQ ACTOR1 (QUOTE !<))
06400 (!< (CADR VARPAT) DATAPAT MALISTV1 MALISTV2))
06500 ((EQ ACTOR1 (QUOTE !/,))
06600 (COMMA (CDR VARPAT)
06700 DATAPAT
06800 MALISTV1
06900 MALISTV2))
07000 ((EQ ACTOR1 (QUOTE !;))
07100 (!; (CDR VARPAT)
07200 DATAPAT
07300 MALISTV1
07400 MALISTV2
07500 T))
07600 ((EQ ACTOR2 (QUOTE !>))
07700 (!? (CDR DATAPAT)
07800 VARPAT
07900 MALISTV2
08000 MALISTV1
08100 NIL))
08200 ((EQ ACTOR2 (QUOTE !;))
08300 (!; (CDR DATAPAT)
08400 VARPAT
08500 MALISTV2
08600 MALISTV1
08700 NIL))
08800 ((EQ ACTOR2 (QUOTE !/,))
08900 (COMMA (CDR DATAPAT)
09000 VARPAT
09100 MALISTV2
09200 MALISTV1))
09300 ((MATCH1 (CAR VARPAT) (CAR DATAPAT))
09400 (MATCH1 (CDR VARPAT) (CDR DATAPAT)))))))
09500 EXPR)
09600
09700 (DECLARE (UNSPECIAL MALISTV2))
09800
09900 (DEFPROP COMMA
10000 (LAMBDA(VARSPEC DATAPAT MV1 MV2)
10100 ((LAMBDA(VAR VALSPEC)
10200 (COND
10300 (VALSPEC
10400 ((LAMBDA(VAL)
10500 (COND
10600 ((MATCH2 DATAPAT VAL MV2) (MBINDV VAR VAL MV1))))
10700 ((LAMBDA (MALIST) (EVAL (CAR VALSPEC))) (CDR MV1))))
10800 (((LAMBDA(VAL)
10900 (COND
11000 ((EQ VAL (QUOTE *UNASSIGNED))
11100 (TRYASSIGN VAR
11200 DATAPAT
11300 (CDR MV1)
11400 MV2
11500 (EQ MV1 MALISTV1)
11600 NIL))
11700 ((MATCH2 DATAPAT VAL MV2))))
11800 ((LAMBDA (MALIST) (!/,1 VAR)) (CDR MV1))))))
11900 (CAR VARSPEC)
12000 (CDR VARSPEC)))
12100 EXPR)
12200
12300 (DECLARE (UNSPECIAL MALISTV1))
12400
12500 (DEFPROP MATCH2
12600 (LAMBDA(VARPAT EXP MV)
12700 (COND ((ATOM VARPAT) (EQUAL VARPAT EXP))
12800 (((LAMBDA(ACTOR)
12900 (COND
13000 ((MEMQ ACTOR (QUOTE (!? !> !')))
13100 (MBINDR (CADR VARPAT) (CDDR VARPAT) EXP MV))
13200 ((EQ ACTOR (QUOTE !/,))
13300 ((LAMBDA(VAR VALSPEC)
13400 (COND
13500 (VALSPEC
13600 ((LAMBDA(VAL)
13700 (COND
13800 ((EQUAL VAL EXP) (MBINDV VAR EXP MV))))
13900 ((LAMBDA (MALIST) (EVAL (CAR VALSPEC)))
14000 (CDR MV))))
14100 (((LAMBDA(VAL)
14200 (COND
14300 ((EQ VAL (QUOTE *UNASSIGNED))
14400 (MSET VAR EXP (CDR MV)))
14500 ((EQUAL VAL EXP))))
14600 ((LAMBDA (MALIST) (!/,1 VAR)) (CDR MV))))))
14700 (CADR VARPAT)
14800 (CDDR VARPAT)))
14900 ((EQ ACTOR (QUOTE !;))
15000 (PROG (VAR VALV RS)
15100 (SETQ VAR (CADR VARPAT))
15200 (SETQ RS (CDDR VARPAT))
15300 (RETURN
15400 (COND
15500 ((SETQ VALV (ASSQ VAR (CDR MV)))
15600 (AND
15700 (COND
15800 ((EQ (SETQ VALV (CADR VALV))
15900 (QUOTE *UNASSIGNED))
16000 (MSET VAR EXP (CDR MV)))
16100 ((EQUAL VALV EXP)))
16200 (SATISFY RS (CDR MV))))
16300 ((CHECKVAL VAR)
16400 (AND (EQUAL VALV EXP)
16500 (SATISFY RS (CDR MV))))
16600 ((MBINDR VAR RS EXP MV))))))
16700 ((EQ ACTOR (QUOTE !<)) NIL)
16800 ((ATOM EXP) NIL)
16900 ((MATCH2 ACTOR (CAR EXP) MV)
17000 (MATCH2 (CDR VARPAT) (CDR EXP) MV))))
17100 (CAR VARPAT)))))
17200 EXPR)
17300
17400 (DEFPROP !?
17500 (LAMBDA(VARSPEC PAT VALISTV PALISTV VARSALLOWED)
17600 ((LAMBDA(VAR RS VARS)
17700 (COND
17800 (VARS
17900 (COND
18000 ((OR VARSALLOWED (NOT (HASMUSTASSIGNS VARS)))
18100 (COND ((HASVARS VARS)
18200 (MBINDV VAR (QUOTE *UNASSIGNED) VALISTV))
18300 ((OR (NOT VAR)
18400 (MBINDR VAR
18500 RS
18600 (VARSUBST PAT (CDR PALISTV))
18700 VALISTV)))))))
18800 (T (MBINDR VAR RS PAT VALISTV))))
18900 (CAR VARSPEC)
19000 (CDR VARSPEC)
19100 (FINDVARS PAT PALISTV)))
19200 EXPR)
19300
19400 (DEFPROP !>
19500 (LAMBDA(VARSPEC PAT VALISTV PALISTV)
19600 ((LAMBDA(VAR RS VARS)
19700 (COND (VARS
19800 (COND ((HASVARS VARS) NIL)
19900 (T
20000 (OR (NOT VAR)
20100 (MBINDR VAR
20200 RS
20300 (VARSUBST PAT (CDR PALISTV))
20400 VALISTV)))))
20500 (T (MBINDR VAR RS PAT VALISTV))))
20600 (CAR VARSPEC)
20700 (CDR VARSPEC)
20800 (FINDVARS PAT PALISTV)))
20900 EXPR)
23400 (DEFPROP !<
23500 (LAMBDA(VAR PAT VALISTV PALISTV)
23600 ((LAMBDA(VARS)
23700 (COND
23800 (VARS
23900 (COND
24000 ((HASVARS VARS)
24100 (OR (NOT VAR)
24200 (MBIND VAR
24300 (VARSUBST PAT (CDR PALISTV))
24400 VALISTV)))))))
24500 (FINDVARS PAT PALISTV)))
24600 EXPR)
24700
24800 (DEFPROP !;
24900 (LAMBDA(VARSPEC PAT VALISTV PALISTV MUSTBIND)
25000 (PROG (VAR VALV RS)
25100 (SETQ VAR (CAR VARSPEC))
25200 (SETQ RS (CDR VARSPEC))
25300 (RETURN
25400 (COND
25500 ((SETQ VALV (ASSQ VAR (CDR VALISTV)))
25600 (COND
25700 ((EQ (SETQ VALV (CADR VALV)) (QUOTE *UNASSIGNED))
25800 (TRYASSIGN VAR
25900 PAT
26000 (CDR VALISTV)
26100 PALISTV
26200 MUSTBIND
26300 RS))
26400 ((MATCH2 PAT VALV PALISTV)
26500 (SATISFY RS (CDR VALISTV)))))
26600 ((CHECKVAL VAR)
26700 (AND (MATCH2 PAT VALV PALISTV)
26800 (SATISFY RS (CDR VALISTV))))
26900 (MUSTBIND (!> VARSPEC PAT VALISTV PALISTV))
27000 ((!? VARSPEC PAT VALISTV PALISTV NIL))))))
27100 EXPR)
27200
27300 (DEFPROP CHECKVAL
27400 (LAMBDA(VAR)
27500 (COND
27600 ((SETQ VALV (VLOC VAR))
27700 (NOT (EQ (SETQ VALV (CADR VALV)) (QUOTE *UNASSIGNED))))
27800 ((SETQ VALV (BOUNDP VAR))
27900 (NOT (EQ (SETQ VALV (CDR VALV)) (QUOTE *UNASSIGNED))))))
28000 EXPR)
28100
28200 (DECLARE (UNSPECIAL VALV))
28300
28400 (DEFPROP FINDVARS
28500 (LAMBDA(PAT MALISTV)
28600 (COND ((ATOM PAT) NIL)
28700 (((LAMBDA(CAR)
28800 (COND
28900 ((EQ CAR (QUOTE !/,))
29000 ((LAMBDA(VAR VALSPEC)
29100 (COND
29200 ((OR (NULL VALSPEC) NOBIND)
29300 (GETSPEC (QUOTE !/,) VAR (CDR MALISTV)))
29400 ((MBINDV VAR
29500 ((LAMBDA(MALIST)
29600 (EVAL (CAR VALSPEC)))
29700 (CDR MALISTV))
29800 MALISTV)
29900 (LIST (QUOTE NIL)))))
30000 (CADR PAT)
30100 (CDDR PAT)))
30200 ((EQ CAR (QUOTE !;))
30300 ((LAMBDA(VAR MALIST)
30400 (COND
30500 ((ASSIGNED? VAR) (LIST NIL))
30600 ((OR NOBIND (ASSQ VAR MALIST))
30700 (GETSPEC (QUOTE !;) VAR MALIST))
30800 ((MBINDV VAR (QUOTE *UNASSIGNED) MALISTV)
30900 (LIST (QUOTE !>)))))
31000 (CADR PAT)
31100 (CDR MALISTV)))
31200 ((ACTOR CAR)
31300 (COND (NOBIND
31400 (GETSPEC CAR (CADR PAT) (CDR MALISTV)))
31500 ((MBINDV (CADR PAT)
31600 (QUOTE *UNASSIGNED)
31700 MALISTV)
31800 (LIST CAR))))
31900 ((NCONC (FINDVARS CAR MALISTV)
32000 (FINDVARS (CDR PAT) MALISTV)))))
32100 (CAR PAT)))))
32200 EXPR)
32300
32400 (DEFPROP HASMUSTASSIGNS
32500 (LAMBDA(VARS)
32600 (PROG(V)(SETQ V VARS)
32700 A(COND((NULL V)(RETURN NIL))
32800 ((MEMQ(CAR V)(QUOTE(!> !')))(RETURN T)))
32900 (SETQ V(CDR V))(GO A)
33000 ))
33100 EXPR)
33200
33300 (DEFPROP HASVARS
33400 (LAMBDA(VARS)
33500 (PROG (V)(SETQ V VARS)
33510 A(COND((NULL V)(RETURN NIL))
33520 ((CAR V)(RETURN T)))
33530 (SETQ V(CDR V))(GO A)
33540 ))
33600 EXPR)
33700
33800 (DEFPROP VARSUBST
33900 (LAMBDA(PAT MALIST)
34000 (COND ((ATOM PAT) PAT)
34100 ((ACTOR (CAR PAT)) (ACTORSUBST PAT MALIST))
34200 ((CONS (VARSUBST (CAR PAT) MALIST)
34300 (VARSUBST (CDR PAT) MALIST)))))
34400 EXPR)
34500
34600 (DEFPROP ACTOR
34700 (LAMBDA (ATOM) (MEMQ ATOM (QUOTE (!> !? !' !< !/, !;))))
34800 EXPR)
34900 (DEFPROP ACTORSUBST
35000 (LAMBDA(PAT MALIST)
35100 ((LAMBDA(VAR)
35200 ((LAMBDA(VAL)
35300 (COND ((EQ VAL (QUOTE *UNASSIGNED)) PAT) (VAL)))
35400 (!/,1 VAR)))
35500 (CADR PAT)))
35600 EXPR)
35700
35800 (DEFPROP GETSPEC
35900 (LAMBDA(ACTOR VAR MALIST)
36000 (COND
36100 ((EQ (!/,1 VAR) (QUOTE *UNASSIGNED))
36200 (COND (NOBIND (CERR UNASSIGNED VARIABLE IN INSTANCE))
36300 ((LIST ACTOR))))
36400 ((LIST NIL))))
36500 EXPR)
36600
36700 (DEFPROP MBIND
36800 (LAMBDA(VAR VAL ALISTV)
36900 (COND (NOBIND (MSET VAR VAL (CDR ALISTV)))
37000 ((RPLACD ALISTV
37100 (CONS (LIST VAR VAL) (CDR ALISTV))))))
37200 EXPR)
37300
37400 (DEFPROP MBINDV
37500 (LAMBDA(VAR VAL ALISTV)
37600 (COND ((NOT VAR))
37700 (NOBIND (MSET VAR VAL (CDR ALISTV)))
37800 ((RPLACD ALISTV
37900 (CONS (LIST VAR VAL) (CDR ALISTV))))))
38000 EXPR)
38100
38200 (DECLARE (UNSPECIAL NOBIND))
38300
38400 (DEFPROP MBINDR
38500 (LAMBDA(VAR RESTRICTIONS VAL ALISTV)
38600 (OR (NOT VAR)
38700 (AND (MBIND VAR VAL ALISTV)
38800 (SATISFY RESTRICTIONS (CDR ALISTV)))))
38900 EXPR)
39000
39100 (DEFPROP !/, (LAMBDA (L) (!/,1 (CAR L))) FEXPR)
39200
39300 (DEFPROP !/,1
39400 (LAMBDA(VAR/ )
39500 ((LAMBDA (PAIR) (COND (PAIR (CADR PAIR)) ((RVALUE VAR/ ))))
39600 (ASSQ VAR/ MALIST)))
39700 EXPR)
39800
39900 (DEFPROP SATISFY
40000 (LAMBDA (RS MALIST) (OR (NULL RS) (APPLY (QUOTE AND) RS)))
40100 EXPR)
40200
40300 (DECLARE (UNSPECIAL MALIST))
40400 (DEFPROP MSET
40500 (LAMBDA(VAR VAL MALIST)
40600 ((LAMBDA(PAIR)
40700 (PROG NIL
40800 (COND (PAIR (RPLACA (CDR PAIR) VAL) VAL)
40900 ((CERR VARIABLE
41000 (/@ . VAR)
41100 UNBOUND
41200 IN
41300 MATCH
41400 ALIST)))
41500 (RETURN T)))
41600 (ASSQ VAR MALIST)))
41700 EXPR)
41800
41900 (DEFPROP ASSIGNED?
42000 (LAMBDA(VAR)
42100 (PROG (VAL)
42200 (RETURN
42300 (COND
42400 ((SETQ VAL (VLOC VAR))
42500 (NOT (EQ (CADR VAL) (QUOTE *UNASSIGNED))))
42600 ((SETQ VAL (BOUNDP VAR))
42700 (NOT (EQ (CDR VAL) (QUOTE *UNASSIGNED))))))))
42800 EXPR)